open Ast
open Types

module type ICOMPILER =
sig
	val compile: (Ast.expr * string list) -> (Types.instr Types.mpair ref)
	exception Comp_Exception of string
end;;

module COMPILER : ICOMPILER =
struct
	exception Comp_Exception of string
	
	(* Funzione che data una variabile e la lista delle variabili restituisce la posizione corrispondente *) 
	let pos(nlist, var) =
		let rec pos_aux(l, v, i) = match l with x:: tail when x = v -> i
			| _:: tail -> pos_aux(tail, v, i + 1)
			| [] -> raise (Comp_Exception "Errore Pos")
		in pos_aux(nlist, var, 0)
	
	(* Aggiunge all'instruction sequence pc l'istruzione instr in coda *)
	let rec add(instr, pc) = match !pc with
			Types.MNil -> pc := Types.MCons(instr, ref Types.MNil)
		| Types.MCons(_, pc1) -> add(instr, pc1)
	
	(* Restituisce la prossima istruzione dell'instruction sequence pc *)
	let rec getNextInstr pc = match !pc with
			Types.MNil -> pc
		| Types.MCons(_, pc1) -> getNextInstr pc1
	
	(* Funzione di compilazione *)
	let rec comp(nlist, exp, pc) = match exp with
		(* VALORI DI BASE *)
			Ast.Int n -> add(Types.ILdbv n, pc)
		
		| Ast.Bool b -> add(Types.BLdbv b, pc)
		
		| Ast.Nil -> add(Types.NLdbv, pc)
		
		| Ast.Var x -> add(Types.Ldpos (pos(nlist, x)), pc)
		
		| Ast.Bfun s -> add(Types.Ldbf s, pc)

		(* APPLY DI FUNZIONI DI BASE BINARIE *)
		| Ast.App(Ast.App(Ast.Bfun2 f2, Ast.Int e1), Ast.Int e2) -> (add(Types.ILdbv e2, pc);
					add(Types.ILdbv e1, pc);
					add(Types.Ldbf f2, pc);
					add(Types.Apply2, pc))
		
		| Ast.App(Ast.App(Ast.Bfun2 f2, Ast.Int e1), Ast.Var y) -> (add(Types.Ldpos (pos(nlist, y)), pc);
					add(Types.ILdbv e1, pc);
					add(Types.Ldbf f2, pc);
					add(Types.Apply2, pc))
		
		| Ast.App(Ast.App(Ast.Bfun2 f2, Ast.Var x), Ast.Int e2) -> (add(Types.ILdbv e2, pc);
					add(Types.Ldpos (pos(nlist, x)), pc);
					add(Types.Ldbf f2, pc);
					add(Types.Apply2, pc))
		
		| Ast.App(Ast.App(Ast.Bfun2 f2, Ast.Bool e1), Ast.Bool e2) -> (add(Types.BLdbv e2, pc);
					add(Types.BLdbv e1, pc);
					add(Types.Ldbf f2, pc);
					add(Types.Apply2, pc))
		
		| Ast.App(Ast.App(Ast.Bfun2 f2, Ast.Bool e1), Ast.Var y) -> (add(Types.Ldpos (pos(nlist, y)), pc);
					add(Types.BLdbv e1, pc);
					add(Types.Ldbf f2, pc);
					add(Types.Apply2, pc))
		
		| Ast.App(Ast.App(Ast.Bfun2 f2, Ast.Var x), Ast.Bool e2) -> (add(Types.BLdbv e2, pc);
					add(Types.Ldpos (pos(nlist, x)), pc);
					add(Types.Ldbf f2, pc);
					add(Types.Apply2, pc))
		
		| Ast.App(Ast.App(Ast.Bfun2 f2, Ast.Int e1), e2) -> let is = ref Types.MNil in
				(comp(nlist, e2, is);
					add(Types.Store, is);
					add(Types.Ldsus is, pc);
					add(Types.ILdbv e1, pc);
					add(Types.Ldbf f2, pc);
					add(Types.Apply2, pc))
		
		| Ast.App(Ast.App(Ast.Bfun2 f2, Ast.Bool e1), e2) -> let is = ref Types.MNil in
				(comp(nlist, e2, is);
					add(Types.Store, is);
					add(Types.Ldsus is, pc);
					add(Types.BLdbv e1, pc);
					add(Types.Ldbf f2, pc);
					add(Types.Apply2, pc))
		
		| Ast.App(Ast.App(Ast.Bfun2 f2, e1), Ast.Int e2) -> let is = ref Types.MNil in
				(comp(nlist, e1, is);
					add(Types.Store, is);
					add(Types.ILdbv e2, pc);
					add(Types.Ldsus is, pc);
					add(Types.Ldbf f2, pc);
					add(Types.Apply2, pc))
		
		| Ast.App(Ast.App(Ast.Bfun2 f2, e1), Ast.Bool e2) -> let is = ref Types.MNil in
				(comp(nlist, e1, is);
					add(Types.Store, is);
					add(Types.BLdbv e2, pc);
					add(Types.Ldsus is, pc);
					add(Types.Ldbf f2, pc);
					add(Types.Apply2, pc))
		
		| Ast.App(Ast.App(Ast.Bfun2 f2, Ast.Var x), Ast.Var y) -> (add(Types.Ldpos (pos(nlist, y)), pc);
					add(Types.Ldpos (pos(nlist, x)), pc);
					add(Types.Ldbf f2, pc);
					add(Types.Apply2, pc))
		
		| Ast.App(Ast.App(Ast.Bfun2 f2, e1), e2) -> let is1 = ref Types.MNil and is2 = ref Types.MNil in
				(comp(nlist, e2, is1);
					comp(nlist, e1, is2);
					add(Types.Store, is1);
					add(Types.Store, is2);
					add(Types.Ldsus is1, pc);
					add(Types.Ldsus is2, pc);
					add(Types.Ldbf f2, pc);
					add(Types.Apply2, pc))
		
		(* APPLY  DI DUE ESPRESSIONI *)
		| Ast.App(e1, e2) -> (match e2 with Ast.Int v -> (add(Types.ILdbv v, pc);
								comp(nlist, e1, pc);
								add(Types.Apply, pc))
					| Ast.Bool v -> (add(Types.BLdbv v, pc);
								comp(nlist, e1, pc);
								add(Types.Apply, pc))
					| Ast.Var v -> (add(Types.Ldpos (pos(nlist, v)), pc);
								comp(nlist, e1, pc);
								add(Types.Apply, pc));
					| _ -> let is1 = ref Types.MNil in
							(comp(nlist, e2, is1);
								add(Types.Store, is1);
								add(Types.Ldsus is1, pc);
								comp(nlist, e1, pc);
								add(Types.Apply, pc)))
		
		(* CLOSURE *)
		| Ast.Fun(var, exp) -> let is1 = ref Types.MNil in
				(comp(var:: nlist, exp, is1);
					add(Types.Exit, is1);
					add(Types.Ldcl is1, pc))
		
		(* IF-THEN-ELSE *)
		| Ast.Cond(e1, e2, e3) -> let l1 = ref Types.MNil in
				(comp(nlist, e1, pc);
					add(Types.Ifskip l1, pc);
					comp(nlist, e2, pc);
					comp(nlist, e3, l1);
					add(Types.Goto (getNextInstr pc), l1))
					
		(* LISTE *)
		| Ast.Cons(e1, e2) ->(	match e1 with
			  Ast.Int _ | Ast.Bool _  | Ast.Nil -> 
								let is1 = ref Types.MNil in
							  (
								comp(nlist, e2, is1);
								add(Types.Store, is1);
								add(Types.Ldsus is1, pc);
								comp(nlist, e1, pc); 
								add(Types.ConsInstr, pc);
								)
			| _-> let is1 = ref Types.MNil and is2 = ref Types.MNil in
							  (
								comp(nlist, e2, is2);
								add(Types.Store, is2);
								add(Types.Ldsus is2, pc);
								
								comp(nlist, e1, is1);
								add(Types.Store, is1);
								add(Types.Ldsus is1, pc);
								add(Types.ConsInstr, pc);
								))
				
		| _ -> raise (Comp_Exception "Errore compilazione")
	
	(* FUNZIONE PRINCIPALE DI COMPILAZIONE *)
	let compile(exp, nlistGlobal) =
		let program = ref Types.MNil in
		comp(nlistGlobal, exp, program);
		add(Types.End, program);
		program
end;;